{-# OPTIONS_GHC -XTemplateHaskell -XNoMonomorphismRestriction #-}
module Text.XML.Xmlable.ParseEsTH(defParseEsN) where

import Language.Haskell.TH
import Control.Monad(liftM, liftM2, guard, msum, mzero)
import Control.Monad.Reader(local)
import Text.XML.Xmlable.Xmlable -- (parse, parseZero, xd2xdc, XmlDescCons(..), throwErrorX, ParserXml)
import Control.Arrow(first, second, (&&&))

parseEs0 = return

calcChildEnv n (XdcElem _ ds) = guard (not . null . drop n $ ds) >> return (xd2xdc $ ds!!n)
calcChildEnv n x = mzero -- throwErrorX $ "Invalid params of calcChildEnv: " ++ show n ++ "; " ++ show x

calcAppEnv n (XdcElem nm ds) = return $ XdcElem nm $ take n ds ++ drop (n+1) ds
calcAppEnv n x = return $ XdcElem (xdcName x) [] -- error $ "Invalid params of calcAppEnv: " ++ show n ++ "; " ++ show x

changeEnv f n = local $ first (>>= f n)

childEnv    = changeEnv calcChildEnv
appEnv      = changeEnv calcAppEnv

p pesn fliprn n isZero fun =
        liftM (fliprn fun) (childEnv n $ if isZero then parseZero else parse) >>= appEnv n . pesn

psum xs fun =
        msum (map ($ fun) $ liftM2 (flip ($)) [False, True] $ zipWith ($) xs [0..])

defParseEsN n = go n
    where
        go n =
            do
                decs <- if n > 1 then go $ n - 1 else return []
                pes <- varE $ mkName $ "parseEs" ++ show (n-1)
                ps <- listE $ map (\k ->
                        [| p $(return pes) $(varE $ mkName $ "flipr" ++ show k) |]) [0..n-1]
                liftM ((:decs) . ($ []) . ValD (VarP $ mkName $ "parseEs" ++ show n) . NormalB) [| psum $(return ps) |]

{-
-- {-# OPTIONS_GHC -XNoMonomorphismRestriction #-} in ParseEs
parseEs3 = psum [
        p parseEs2 flipr0,
        p parseEs2 flipr1,
        p parseEs2 flipr2
    ]

parseEs3 = msum [
        p parseEs2 flipr0 0 False fun,
            -- = childEnv 0 parse >>= return . flipr0 fun >>= appEnv 0 . parseEs2
        p parseEs2 flipr1 1 False fun,
            -- = childEnv 1 parse >>= return . flipr1 fun >>= appEnv 1 . parseEs2
        p parseEs2 flipr2 2 False fun,
        p parseEs2 flipr0 0 True fun,
            -- = childEnv 0 parseZero >>= return . flipr0 fun >>= appEnv 0 . parseEs2
        p parseEs2 flipr1 1 True fun,
        p parseEs2 flipr2 2 True fun
    ]
-}

